perm filename MDSHO.SAI[GEM,MUS]1 blob
sn#227887 filedate 1976-07-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00033 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 BEGIN "MDC"
C00008 00003 REAL PROCEDURE GETVRTS(INTEGER B,TYP)
C00011 00004 PROCEDURE STROOM(REAL R)
C00014 00005 PROCEDURE SHOLET(INTEGER I)
C00016 00006 PROCEDURE NEWRLD
C00018 00007 SIMPLE PROCEDURE NORMD
C00020 00008 PROCEDURE DRAW2(REAL X,YINTEGER I,J,NREAL ARRAY V)
C00022 00009 REAL PROCEDURE RV(INTEGER I)
C00024 00010 PROCEDURE GETROOM
C00026 00011 PROCEDURE SETSTF
C00028 00012 PROCEDURE SHEP_DRAW(INTEGER PP)
C00030 00013 PROCEDURE DATIN(REAL ARRAY V)
C00032 00014 IF NDIMS>3 THEN BEGIN "GT3"
C00034 00015 IF NDIMS=3 THEN BEGIN "EQ3"
C00036 00016 PROCEDURE SHAX
C00038 00017 PROCEDURE KHRSET(INTEGER CHR)
C00044 00018
C00048 00019 PROCEDURE MOVSHO
C00050 00020 AGN: MOVE CH,KHR
C00052 00021 SETRIG: SKIPE R90
C00054 00022 MOV: SKIPN @SHOPP
C00056 00023 SHO: SKIPN BRIDF
C00058 00024 RM1: MOVEI 1,0
C00060 00025 SKPRIT: ADDI PNT,1
C00062 00026 IFC CONVERG THENC
C00063 00027 INTERNAL PROCEDURE SFUNCT(INTEGER NREAL ARRAY A
C00066 00028 PROCEDURE FILOPEN(INTEGER NEWONE)
C00068 00029 PROCEDURE DATNEW(INTEGER NEWONE)
C00071 00030 PROCEDURE ALLCHR
C00073 00031 PROCEDURE GETCHR
C00076 00032 α INITIALIZATION
C00078 00033 NEW1←NEW2←PASS1←1
C00079 ENDMK
C⊗;
BEGIN "MDC"
EXTERNAL REAL PROCEDURE SIN(REAL X);
EXTERNAL REAL PROCEDURE COS(REAL X);
EXTERNAL SAFE INTEGER ARRAY DPYBUF[1:2000];
DEFINE XX1="XX[1]",XX2="XX[2]",XX3="XX[3]",XX4="XX[4]";
DEFINE YY1="YY[1]",YY2="YY[2]",YY3="YY[3]",YY4="YY[4]";
DEFINE TIL="STEP 1 UNTIL", LPNTS="80", α="COMMENT",
↓="'15&'12",π="3.14159626535";
REQUIRE "GEOMES.HDR[GEM,MUS]" SOURCE_FILE;
INTERNAL INTEGER NPNTS;INTEGER LETX,LETY,SZSCAL,BSIZ;
INTEGER I,CTRL,META,DISTQ,AXOK,BIGDIM,KHR,NDIMS,AXNUM;
INTEGER ASCALE,LETXX,LETYY,SMLETS,HAVROOM,HIDE,NPLESS,KL;
INTEGER BRK,BRK9,EOF,FAIL,J,STP,OLDKHR,LABOK,R90,SKMOV,NEWDAT;
INTEGER X1,Y1,X2,Y2,NOFIL2,BRIDF,OFFL,OFFR,NOREP,SHEPARD,FINE;
INTEGER SCALP,SHOPP,OLDCTR,OLDMET,AD1,AD2,ADX,ADY,ADZ,LABS,LABP;
INTEGER CHR,SUBIN,NUMSUBS,NPSAV,CONVSHO,N,IER,LIM,NEW1,NEW2,GOSHO;
INTEGER SPLIT,SHRT,ALLDIM,SUBNOW,PASS1,WROOM,ROOMDIV,MROOM,NUROOM;
INTEGER WAL,FLO,CAM,ROO,CUB,FR,WALP,FLOP,CUBP,TXT,TST,PLT,NW;
REAL CX,CY,CZ,ONE,TWO,THREE,WSQZ,MAXVAL,CAMX,CAMY,CAMZ,R,R1,R2;
REAL CSL,SNL,CCSL,SSNL,SCAL,SIZ,RSIZ,LDIS,XROOM,YROOM,XSROOM,YSROOM;
REAL ROTDEL,TRNDEL,CS,SN,CSPL,SNSPL,ANGLE,NUMBR,VAL,CUTOFF,SCL;
REAL KSCALE,RMIN,RDSCAL,DIF1,DIF2,XSCL,YSCL;
SAFE INTEGER ARRAY CUBE,FLOOR,WALL[1:LPNTS];
SAFE STRING ARRAY LABL,LABSAV[1:LPNTS],DATFIL[1:2];
INTERNAL SAFE REAL ARRAY SCALE[1:2];
SAFE REAL ARRAY FOO[1:1],LTRX,LTRY[1:LPNTS/4,1:25];
SAFE INTEGER ARRAY SHOW,AXIS[1:2],LTRP[1:LPNTS/4,1:25];
SAFE INTEGER ARRAY DIM[1:4],LTRN[1:LPNTS];
STRING LABFIL,S,NUMSET,DEV,FILE,PFIL,FNT;
SAFE REAL ARRAY XX,YY[1:4];
INTERNAL SAFE REAL ARRAY VERTWC[1:3,1:LPNTS];
DEFINE CONVERG="TRUE";
IFC CONVERG THENC
REQUIRE "FUNCT.REL[MDS,JMG]" LOAD_MODULE;
FORTRAN PROCEDURE FUNCT;
REQUIRE "FMFP.REL[MDS,JMG]" LOAD_MODULE;
FORTRAN PROCEDURE FMFP;
SAFE REAL ARRAY H[1:LPNTS*(LPNTS+7)/2];
SAFE REAL ARRAY A[1:3,1:3];
SAFE REAL ARRAY GRAD[1:3,1:3];
SAFE REAL ARRAY SAVEWC[1:3,1:LPNTS];
ENDC
REAL PROCEDURE GETVRTS(INTEGER B,TYP);
BEGIN INTEGER F,E,V,K,L;
IF TYP≠"C" THEN F←PFACE(B) ELSE
F←PFACE(PFACE(B));E←PED(F,B);V←PVT(E);
XX[1]←XPP(V)*SCL;YY[1]←YPP(V)*SCL;
V←NVT(E);
XX[2]←XPP(V)*SCL;YY[2]←YPP(V)*SCL;
E←ECCW(E,F);E←ECCW(E,F);V←PVT(E);
XX[4]←XPP(V)*SCL;YY[4]←YPP(V)*SCL;
V←NVT(E);
XX[3]←XPP(V)*SCL;YY[3]←YPP(V)*SCL;
FOR K←1 TIL 3 DO FOR L←1 TIL 4-K DO
IF YY[L]<YY[L+1] THEN
BEGIN YY[L]↔YY[L+1];XX[L]↔XX[L+1];END;
IF XX[1]<XX[2] THEN BEGIN XX[1]↔XX[2];YY[1]↔YY[2];END;
IF XX[4]<XX[3] THEN BEGIN XX[4]↔XX[3];YY[4]↔YY[3];END;
IF TST THEN BEGIN
AIVECT(XX1,YY1);AVECT(XX2,YY2);
AVECT(XX3,YY3);AVECT(XX4,YY4);AVECT(XX1,YY1);
END;
END;
PROCEDURE ALTSIZ(INTEGER J);
BEGIN REAL ADDFAC;
if meta then R1←.2 else if ctrl then R1←.12
else R1←.05;
if ¬addfac then addfac←1;
if meta and ctrl then begin
OUTSTR(↓&" altsiz crossover [0=front 1=back] ("&cvf(addfac/2)&")←");
IF LENGTH(S←INCHWL) THEN ADDFAC←2*REALSCAN(S,0);END;
FOR I←1 TIL NPNTS DO BEGIN
R←ADDFAC+VERTWC[3,I]/RSIZ*R1;IF J THEN R←1/R;
SHRINK(-CUBE[I],R,R,R);
SHRINK(-WALL[I],0,R,R);SHRINK(-FLOOR[I],R,0,R);
SIZ←SIZ*R;
END;
END;
PROCEDURE TRCAM(REAL R1,R2;INTEGER AX);
BEGIN
if META then BEGIN
IF AX="X" THEN TRANSL(-CAM,R1,0,0)
ELSE TRANSL(-CAM,0,R1,0);
END else if ctrl then BEGIN
IF AX="X" THEN TRANSL(-CAM,R2,0,0)
ELSE TRANSL(-CAM,0,R2,0);
END else BEGIN
OUTSTR(" "&AX&"cam ←");
IF LENGTH(S←INCHWL) THEN BEGIN
R←REALSCAN(S,0);
IF AX="X" THEN TRANSL(-CAM,R,0,0)
ELSE TRANSL(-CAM,0,R,0);
END;
END;
END;
PROCEDURE STROOM(REAL R);
BEGIN
FOR I←1 TIL NPNTS DO BEGIN
R1←VERTWC[3,I]; VERTWC[3,I]←VERTWC[3,I]*R;
R1←VERTWC[3,I]-R1;
TRANSL(WALL[I],0,0,R1); TRANSL(CUBE[I],0,0,R1);
TRANSL(FLOOR[I],0,0,R1);
if meta then begin
SHRINK(-WALL[I],0,0,R);
SHRINK(-CUBE[I],0,0,R);
SHRINK(-FLOOR[I],0,0,R);
end;
END;
SHRINK(ROO,0,0,R);
END;
PROCEDURE STRSQR(REAL R);
BEGIN
FOR I←1 TIL NPNTS DO BEGIN
SHRINK(-WALL[I],0,0,R);
SHRINK(-CUBE[I],0,0,R);
SHRINK(-FLOOR[I],0,0,R);
END;
END;
PROCEDURE SHWALL(REAL RMETA,RCTRL);
BEGIN
if meta then BEGIN R2←RSIZ; RSIZ←RSIZ*RMETA;
R1←RMETA; R←RSIZ-R2; END else
if ctrl then BEGIN R2←RSIZ; RSIZ←RSIZ*RCTRL;
R1←RCTRL; R←RSIZ-R2; END else
BEGIN outstr(" walls ("&cvf(RSIZ)&")←");
if length(s←inchwl) then BEGIN
R←REALSCAN(S,0); R1←R/RSIZ;
R2←RSIZ; RSIZ←R; R←R2-R;
END;
END;
FOR I←1 TIL NPNTS DO BEGIN
TRANSL(WALL[I],-R,0,0);
TRANSL(FLOOR[I],0,-R,0);
END;
SHRINK(ROO,R1,R1,R1);
END;
PROCEDURE ASKCAM(INTEGER AX;REFERENCE REAL CAMAX);
BEGIN outstr(" "&AX&"rot ("&cvf(CAMAX)&")←");
if length(s←inchwl) then BEGIN
R1←realscan(s,0);R←R1-CAMAX;CAMAX←R1;
IF AX="X" THEN ROTATE(XWD(FR,CAM),R,0,0)
ELSE ROTATE(XWD(FR,CAM),0,R,0);
END;
END;
PROCEDURE SHROOM(REAL R1);
BEGIN
R←RSIZ; RSIZ←RSIZ*R1; R←R-RSIZ;
if meta then begin SIZ←SIZ*R1;
FOR I←1 TIL NPNTS DO BEGIN
SHRINK(CUBE[I],R1,R1,R1);
SHRINK(WALL[I],R1,R1,R1);
SHRINK(FLOOR[I],R1,R1,R1);
END;
end ELSE
FOR I←1 TIL NPNTS DO BEGIN
TRANSL(WALL[I],R,0,0);
TRANSL(FLOOR[I],0,R,0);
END;
FOR I←1 TIL NPNTS DO
FOR J←1 TIL 3 DO VERTWC[J,I]←VERTWC[J,I]*R1;
SHRINK(ROO,R1,R1,R1);
END;
PROCEDURE SHOLET(INTEGER I);
BEGIN INTEGER J,N; REAL XXX,YYY,XI,YI;
REAL XD0,YD0,XDT,XDB,YDR,YDL,XDF,YDF;
XDT←XX1-XX2; XDB←XX4-XX3; YDL←YY2-YY3; YDR←YY1-YY4;
YD0←YY4-YY3; YDF←YDR-YDL; XD0←XX2-XX3; XDF←XDT-XDB;
N←LTRN[I];
FOR J←1 TIL N DO BEGIN
XI←LTRX[I,J]; YI←LTRY[I,J];
XXX←XX3+YI*XD0+XI*(XDB+YI*XDF);
YYY←YY3+XI*YD0+YI*(YDL+XI*YDF);
IF LTRP[I,J] THEN AIVECT(XXX,YYY)
ELSE AVECT(XXX,YYY);
END;
END;
PROCEDURE LETRS;
BEGIN INTEGER I;
DPYSET(DPYBUF);
IF ¬PLT THEN
FOR I←1 TIL NPNTS DO BEGIN
GETVRTS(CUBE[I],"C");SHOLET(I);
GETVRTS(WALL[I],0);SHOLET(I);
GETVRTS(FLOOR[I],0);SHOLET(I);
DPYOUT(2);
END ELSE BEGIN
FOR I←1 TIL NPNTS DO BEGIN
GETVRTS(CUBE[I],"C");SHOLET(I);END;
PLOTO(PFIL&".CBL");
DPYSET(DPYBUF);
FOR I←1 TIL NPNTS DO BEGIN
GETVRTS(WALL[I],0);SHOLET(I);
GETVRTS(FLOOR[I],0);SHOLET(I);END;
PLOTO(PFIL&".WAL");
END;
PLT←0;
END;
PROCEDURE NEWRLD;
BEGIN INTEGER I;
FOR I←1 TIL NPNTS DO BEGIN
TRANSL(WALL[I],-10,0,0);
TRANSL(FLOOR[I],-10,0,0);
END; NW←1;
TRANSL(ROO,-10,0,0);
END;
PROCEDURE OLWRLD;
BEGIN INTEGER I;
FOR I←1 TIL NPNTS DO BEGIN
TRANSL(WALL[I],10,0,0);
TRANSL(FLOOR[I],10,0,0);
END; NW←0;
TRANSL(ROO,10,0,0);
END;
PROCEDURE SHOSTR(STRING S;REAL LX,LY);
BEGIN REAL RDIS,XAV,YAV;INTEGER J;
RDIS←RMIN+(XX4-XX3)/RDSCAL;
YAV←(YY1+YY2+YY3+YY4)/4;
XAV←(XX3+XX4)/2;
AIVECT(XAV-RDIS-LX,YAV-LY);
J←LOP(S);DPYSST(J);
AIVECT(XAV+RDIS-LX,YAV-LY);
J←LOP(S);DPYSST(J);
END;
PROCEDURE TXTROOM;
BEGIN INTEGER I;
DPYSET(DPYBUF);
FOR I←1 TIL NPNTS DO BEGIN
GETVRTS(CUBE[I],"C");SHOSTR(LABL[I],LETX,LETY);
GETVRTS(WALL[I],0);SHOSTR(LABL[I],LETXX,LETYY);
GETVRTS(FLOOR[I],0);SHOSTR(LABL[I],LETXX,LETYY);
END;
IF PLT THEN PLOTO(PFIL&".LTR") ELSE DPYOUT(2);
PLT←0;
END;
PROCEDURE CALPLO;
BEGIN
IF ¬NW THEN BEGIN
OUTSTR(↓&"File: ");PFIL←INCHWL;
PLOTO(PFIL);
END ELSE PLOTO(PFIL&".CUB");
END;
PROCEDURE APOINT(INTEGER X,Y);
BEGIN AIVECT(X,Y);AVECT(X,Y);END;
PROCEDURE DPYIT;
IF HIDE THEN SHOW2(0,1) ELSE GEODPY;
SIMPLE PROCEDURE NORMD;
BEGIN "NORMD"
INTEGER I,J,N;REAL R,R1,R2;
N←3 MIN NDIMS;
R←R2←0.0; R1←1.0+SIZ*2;
FOR I←1 TIL N DO BEGIN
IF NEW1 THEN BEGIN
FOR J←1 TIL NPNTS DO R←R MAX ABS(VERTWC[I,J]);
END;
IF NEW2 THEN BEGIN
FOR J←NPNTS+1 TIL 2*NPNTS DO R2←R2 MAX ABS(VERTWC[I,J]);
END;
END;
R←R*R1; R2←R2*R1; MAXVAL←0.0;
FOR I←1 TIL N DO BEGIN
IF NEW1 THEN FOR J←1 TIL NPNTS DO
MAXVAL←MAXVAL MAX ABS(VERTWC[I,J]←VERTWC[I,J]/R);
IF NEW2 THEN FOR J←NPNTS+1 TIL 2*NPNTS DO
VERTWC[I,J]←VERTWC[I,J]/R2;
END;
RSIZ←1.0;
END "NORMD";
PROCEDURE LSTDIM(INTEGER I,J,N;REAL ARRAY V);
BEGIN INTEGER CCCHN,FLG,K;LABEL FILI;
STRING FILE;
CCCHN←GETCHAN;
OPEN(CCCHN,"DSK",0,0,3,128,0,0);
FILI: OUTSTR(↓&"FILE : ");FILE←INCHWL;
ENTER(CCCHN,FILE&".DIM",FLG);
IF FLG THEN GO TO FILI;
SETFORMAT(0,3);
OUT(CCCHN,CVS(N)&↓);
FOR K←1 TIL N DO
OUT(CCCHN,CVS(K)&"="&LABL[K]&" "&
CVF(V[I,K])&" "&CVF(V[J,K])&↓);
CLOSE(CCCHN);RELEASE(CCCHN);
END;
PROCEDURE DRAW2(REAL X,Y;INTEGER I,J,N;REAL ARRAY V);
BEGIN INTEGER K;
FOR K←1 TIL N DO BEGIN
APOINT(V[I,K]+X,V[J,K]+Y);
DPYSST(LABL[K]);
END;
END;
PROCEDURE ROT2(INTEGER I,J,N;REAL ARRAY V);
BEGIN INTEGER K;REAL R1,R2;
FOR K←1 TIL N DO BEGIN
R1←V[I,K]*CSL+V[J,K]*SNL;
R2←-V[I,K]*SNL+V[J,K]*CSL;
V[I,K]←R1;V[J,K]←R2;
END;
END;
PROCEDURE ALLSHO(INTEGER N;REAL ARRAY V);
BEGIN INTEGER K,L;REAL X,Y;
DPYSET(DPYBUF);
FOR K←1 STEP 2 UNTIL NDIMS DO BEGIN
CASE K OF BEGIN
[1] BEGIN X←-250;Y←250;END;
[3] BEGIN X←250;Y←250;END;
[5] BEGIN X←0;Y←-250;END
END;
IF SUBNOW THEN Y←-250;
AIVECT(X-225,Y+225);AVECT(X+225,Y+225);
AVECT(X+225,Y-225);AVECT(X-225,Y-225);
AVECT(X-225,Y+225);
IF K<NDIMS THEN L←K+1 ELSE L←K-1;
DRAW2(X,Y,K,L,N,V);
END;
DPYOUT(1);
END;
REAL PROCEDURE RV(INTEGER I);
START_CODE MOVE 1,I;END;
PROCEDURE GETLETS;
BEGIN INTEGER I,J,K,L,M,N; STRING S,S1;
SAFE INTEGER ARRAY PNTR[1:44];
SAFE INTEGER ARRAY TMP[1:337*3];
OPEN(13,"DSK",'10,10,0,0,0,0);
LOOKUP(13,"LETRS.DAT[MDS,JMG]",FAIL);
IF FAIL THEN OUTSTR("NOT FOUND: LETRS.DAT[EXP,JMG]");
ARRYIN(13,PNTR[1],44);ARRYIN(13,TMP[1],337*3);
CLOSE(13);
FOR I←1 TIL NPNTS DO BEGIN
S←LABL[I]; N←0; M←0;
FOR L←1 TIL 2 DO BEGIN
K←LOP(S); IF K>"9" THEN K←K-"A"+11 ELSE K←K-"0"+1;
J←(PNTR[K]-1)*3+1;
K←TMP[J]*3; N←K-J+1-3; N←N/3;
FOR K←1 TIL N DO LTRP[I,M+K]←TMP[J+K];J←J+N+1;
IF L=1 THEN
FOR K←1 TIL N DO LTRX[I,M+K]←RV(TMP[J+K])/XSCL+.5-1.02/XSCL
ELSE
FOR K←1 TIL N DO LTRX[I,M+K]←RV(TMP[J+K])/XSCL+.5+1.02/XSCL;
J←J+N+1;
FOR K←1 TIL N DO LTRY[I,M←M+1]←RV(TMP[J+K])/YSCL+.5;
END;
LTRN[I]←M;
END;
END;
PROCEDURE REROOM;
BEGIN INTEGER I;REAL X,Y,Z;
NUROOM←NPNTS;
ROTATE(XWD(FR,CAM),-CAMX,-CAMY,0);
IF ¬WROOM THEN
FOR I←1 TIL NPNTS DO BEGIN
X←VERTWC[1,I];Y←VERTWC[2,I];Z←VERTWC[3,I];
TRANSL(CUBE[I],-X,-Y,-Z);
TRANSL(WALL[I],0,-Y,-Z);
TRANSL(FLOOR[I],-X,0,-Z);
END;
END;
PROCEDURE GETROOM;
BEGIN INTEGER I,WAL,FLO,CUB;
INTEGER B,F,E,V1,V2,V3,V4;
HAVROOM←1; MKUNIV; NUROOM←NPNTS;
FR←ROTATE(0,0,0,0);CAMX←CAMY←0;CAMZ←1.0;
CAM←INCAM("CAMERA");
ROTATE(XWD(FR,CAM),-π/14,π/14,0);
TRANSL(-CAM,-.2,-.15,0);
ROO←INB3D("ROOM");
R←SIZ/2;
WALL[1]←MKBFV; B←WALL[1]; F←PFACE(B); V1←PVT(B);
XWC(V1)←0; YWC(V1)←R; ZWC(V1)←R;
V2←MKEV(F,V1); YWC(V2)←-R;
V3←MKEV(F,V2); ZWC(V3)←-R;
V4←MKEV(F,V3); YWC(V4)←R;
MKFE(V1,F,V4);
TRANSL(WALL[1],-.97,0,0);
FOR I←2 TIL NPNTS DO WALL[I]←MKCOPY(WALL[1]);
FLOOR[1]←MKBFV; B←FLOOR[1]; F←PFACE(B); V1←PVT(B);
YWC(V1)←0; XWC(V1)←R; ZWC(V1)←R;
V2←MKEV(F,V1); XWC(V2)←-R;
V3←MKEV(F,V2); ZWC(V3)←-R;
V4←MKEV(F,V3); XWC(V4)←R;
MKFE(V1,F,V4);
TRANSL(FLOOR[1],0,-.97,0);
FOR I←2 TIL NPNTS DO FLOOR[I]←MKCOPY(FLOOR[1]);
CUBE[1]←MKCUBE(SIZ,SIZ,SIZ);
FOR I←2 TIL NPNTS DO CUBE[I]←MKCOPY(CUBE[1]);
GETLETS;
END;
PROCEDURE SETSTF;
BEGIN
IF NOT PASS1 THEN BEGIN
OUTSTR("Split screen?");
IF INCHRW="Y" THEN NOREP←FALSE ELSE NOREP←TRUE;
OUTSTR('15&'12);
END ELSE BEGIN PASS1←0;NOREP←TRUE;END;
SPLIT←0;
IF ¬NOREP THEN BEGIN SPLIT←1;
SCALE[1]←SCALE[2]←-1150;X1←-250;X2←250;
DPYSET(DPYBUF);
AIVECT(-500,-300);AVECT(+500,-300);
AVECT(+500,+300);
AVECT(-500,+300);AVECT(-500,-300);
AIVECT(0,+300);AVECT(0,-300);
AIVECT(-500,+310);AVECT(-250,+310);
AIVECT(-500,-310);AVECT(-250,-310);
AIVECT(+500,+310);AVECT(+250,+310);
AIVECT(+500,-310);AVECT(+250,-310);
DPYOUT(0);
END ELSE BEGIN
DPYSET(DPYBUF);DPYOUT(0);
X1←X2←0;
SCALE[1]←SCALE[2]← -1350;
END;
END;
PROCEDURE SHEP_DRAW(INTEGER PP);
BEGIN INTEGER NP,I,J,K;REAL YB,YT,XL,XR,XS,YS,YYY,MXX,MXY,MNX,MNY;
DO S←INPUT(3,11) UNTIL CHR=">";
S←INPUT(3,4);S←INPUT(3,6);
NP←CVD(S); MXX←MXY←0;MNX←MNY←100000;
DPYSET(DPYBUF);AIVECT(-300,300);AVECT(-300,-300);AVECT(300,-300);
AIVECT(-380,30);DPYSST("S"); AIVECT(-380,0);DPYSST("I");
AIVECT(-380,-30);DPYSST("M"); AIVECT(-30,-380);DPYSST("DIS");
BEGIN REAL ARRAY DIST,DATA,DHAT[1:NP];
FOR I←1 TIL NP DO BEGIN
S←INPUT(3,4);S←INPUT(3,6);
DIST[I]←REALSCAN(S,0);
MXX←MXX MAX DIST[I];MNX←MNX MIN DIST[I];
S←INPUT(3,4);S←INPUT(3,6);
DATA[I]←REALSCAN(S,0);
MXY←MXY MAX DATA[I];MNY←MNY MIN DATA[I];
S←INPUT(3,4);S←INPUT(3,6);
DHAT[I]←REALSCAN(S,0);
MXX←MXX MAX DHAT[I];MNX←MNX MIN DHAT[I];
END;
YT←MXY;YB←MNY;YS←YB-YT; XL←MNX;XR←MXX;XS←XR-XL;
FOR I←1 TIL NP DO BEGIN
YYY←300-600*(DATA[I]-YT)/YS;
IF SHRT THEN APOINT(-300+600*(DIST[I]-XL)/XS,YYY)
ELSE BEGIN
APOINT(-300+600*(DIST[I]-XL)/XS,YYY);
AIVECT(-300+600*(DHAT[I]-XL)/XS,YYY+7);
AVECT(-300+600*(DHAT[I]-XL)/XS,YYY-7);
END;
END;
END;
IF PP THEN CALPLO ELSE DPYOUT(1); SHEPARD←0;
END;
PROCEDURE DATIN(REAL ARRAY V);
BEGIN STRING S,S1;INTEGER I,J,K,BADIM,I1,I2;LABEL DAGN;
INTEGER OFF,FIL,LSTFIL;
BOOLEAN PROCEDURE SKPSTM;
DO BEGIN DO S←INPUT(3,3) UNTIL CHR="#";
IF EOF THEN BEGIN OUTSTR("
NOT THAT MANY DIMENSIONS AVAILABLE"&↓);
CLOSE(3);RELEASE(3);BADIM←-1;DONE;END;
S←INPUT(3,4);S←INPUT(3,6);
I←CVD(S);S←INPUT(3,7);
END UNTIL I=NDIMS;
DAGN: IF ¬SHEPARD THEN BEGIN
OUTSTR(↓&"Ndims : "); S←INCHRW; OUTSTR(↓);
NDIMS←CVD(S);IF NDIMS=0 THEN BEGIN NEWDAT←-1;RETURN;END;
END;
IF NEW1 AND HAVROOM THEN REROOM;
IF NEW1 AND NEW2 THEN BEGIN I1←1;I2←2;END ELSE
IF NEW1 THEN I1←I2←1 ELSE IF NEW2 THEN I1←I2←2
ELSE BEGIN OUTSTR("No input"&↓);return;END;
FOR FIL←I1 TIL I2 DO BEGIN "LOP2"
IF FIL=2 THEN OFF←NPNTS ELSE OFF←0;
BADIM←0;S←DATFIL[FIL];DEV←SCAN(S,13,I);
IF I≠":" THEN BEGIN S←DEV;DEV←"DSK";END
ELSE IF DEV="U" THEN DEV←"UDP" ELSE DEV←"DSK";
OPEN(3,DEV,0,3,3,128,CHR,EOF);LOOKUP(3,S,FAIL);
SKPSTM; IF BADIM THEN GO TO DAGN;
IF SUBIN THEN BEGIN DO S←INPUT(3,12) UNTIL CHR="%";
S←INPUT(3,4);S←INPUT(3,6);NPNTS←CVD(S);S←INPUT(3,7);
FOR I←1 TIL NPNTS DO LABL[I]←I+"A"-1;
END;
IF SHEPARD THEN RETURN;
IF NDIMS>3 THEN BEGIN "GT3"
IF NOT ALLDIM THEN BEGIN
OUTSTR("DI1,DI2,DI3 : ");
DIM[1]←CVD(INSTR(","));
DIM[2]←CVD(INSTR(","));
DIM[3]←CVD(INCHWL);
FOR I←1 STEP 1 UNTIL NPNTS DO BEGIN
J←K←1;S←INPUT(3,4);
S←INPUT(3,6);IF (CHR←CVD(S))≠I THEN
USERERR(0,0,"MISMATCH :"&CVS(I)&"≠"&CVS(CHR));
DO BEGIN
S←INPUT(3,4);S←INPUT(3,6);
IF DIM[K]=J THEN BEGIN
VERTWC[K,I+OFF]←REALSCAN(S,CHR);
K←K+1;
END;
J←J+1;
END UNTIL J>NDIMS;
IF K≠4 THEN USERERR(0,0,"
INVALID DIMENSION NUMBER");
END;
END ELSE BEGIN REAL R;
R←0;
FOR I←1 TIL NPNTS DO BEGIN S←INPUT(3,4);
S←INPUT(3,6);IF (CHR←CVD(S))≠I THEN
USERERR(0,0,"MISMATCH :"&CVS(I)&"≠"&CVS(CHR));
FOR J←1 TIL NDIMS DO BEGIN
S←INPUT(3,4);S←INPUT(3,6);
R←R MAX (ABS(V[J,I+OFF]←REALSCAN(S,CHR)));
END;
END;
FOR I←1 TIL NPNTS DO FOR J←1 TIL NDIMS DO
V[J,I]←V[J,I]*SCAL/R;
END;
END "GT3" ELSE
IF NDIMS=3 THEN BEGIN "EQ3"
IF ¬ALLDIM THEN BEGIN
FOR I←1 TIL NPNTS DO BEGIN S←INPUT(3,4);
S←INPUT(3,6);IF (CHR←CVD(S))≠I THEN
USERERR(0,0,"MISMATCH :"&CVS(I)&"≠"&CVS(CHR));
FOR J←1 TIL 3 DO BEGIN
S←INPUT(3,4);S←INPUT(3,6);
VERTWC[J,I+OFF]←REALSCAN(S,CHR);
END;
END;
END ELSE BEGIN REAL R;
R←0;
FOR I←1 TIL NPNTS DO BEGIN S←INPUT(3,4);
S←INPUT(3,6);IF (CHR←CVD(S))≠I THEN
USERERR(0,0,"MISMATCH :"&CVS(I)&"≠"&CVS(CHR));
FOR J←1 TIL NDIMS DO BEGIN
S←INPUT(3,4);S←INPUT(3,6);
R←R MAX (ABS(V[J,I+OFF]←REALSCAN(S,CHR)));
END;
END;
FOR I←1 TIL NPNTS DO FOR J←1 TIL NDIMS DO
V[J,I]←V[J,I]*SCAL/R;
END;
END "EQ3" ELSE
IF NDIMS<3 THEN BEGIN "LT3"
FOR I←1 TIL NPNTS DO BEGIN S←INPUT(3,4);
S←INPUT(3,6);IF (CHR←CVD(S))≠I THEN
USERERR(0,0,"MISMATCH :"&CVS(I)&"≠"&CVS(CHR));
FOR J←1 TIL NDIMS DO BEGIN
S←INPUT(3,4);S←INPUT(3,6);
VERTWC[J,I+OFF]←REALSCAN(S,CHR);
END;
FOR J←NDIMS+1 TIL 3 DO
VERTWC[J,I+OFF]←0.0;
END;
END "LT3";
IF NOT CONVSHO THEN NORMD;
CLOSE(3);RELEASE(3);
END "LOP2";
END;
PROCEDURE SHAX;
BEGIN "SHAX"
INTEGER I,M;STRING S;INTEGER ARRAY XX,YY[1:2];
INTEGER CHR1,CHR2,N;REAL SCA;
N←AXNUM;XX[1]←X1;YY[1]←Y1;XX[2]←X2;YY[2]←Y2;
IF N≤2 THEN BEGIN
IF AXIS[N]="X" THEN BEGIN
CHR1←"Y";CHR2←"Z";
END ELSE
IF AXIS[N]="Y" THEN BEGIN
CHR1←"X";CHR2←"Z";
END ELSE
BEGIN CHR1←"X";CHR2←"Y";END;
M←3-N;
IF AXIS[M]=CHR1 THEN AXIS[M]←CHR2
ELSE AXIS[M]←CHR1;
END ELSE AXIS[1]↔AXIS[2];
IF NOFIL2 THEN SCA←SCALE[1] ELSE
SCA←SCALE[1] MAX SCALE[2];
FOR I←1 TIL 2 DO BEGIN
M←(1.5-CX)*SCA/CZ+XX[I];
AIVECT(M,0);
AVECT(-M,0);
S←AXIS[1];DPYBIG(4);
DPYSST(" "&S);
M←(1.5-CY)*SCA/CZ+YY[I];
AIVECT(0,M);
AVECT(0,-M);
S←AXIS[2];
DPYSST(" "&S);
END;
END "SHAX";
SIMPLE PROCEDURE SHLAB;
BEGIN "SHLAB"
STRING S;
AIVECT(-450,460);
IF DISTQ THEN S←"P " ELSE S←"¬P ";
S←S&CVS(NDIMS)&"D ";
IF NDIMS>3 THEN
S←S&"("&CVS(DIM[1])&CVS(DIM[2])&CVS(DIM[3])&")";
S←S&" "&DATFIL[1]&" "&DATFIL[2];
DPYSST(S);
END "SHLAB";
PROCEDURE KHRSET(INTEGER CHR);
BEGIN INTEGER I,KKK;
CASE CHR OF BEGIN "CHRLST"
["B"] if ctrl then SMLETS←1-SMLETS else
BEGIN OUTSTR("size: ");BSIZ←CVD(INCHWL);
DPYBIG(BSIZ);END;
["D"] BEGIN IF DISTQ THEN DISTQ←0 ELSE DISTQ←-1; END;
["E"] if meta then BEGIN ANGLE←ANGLE*2;SNSPL←-SIN(ANGLE);
CSPL←COS(ANGLE);END else
if ctrl then ROTDEL ← ROTDEL*2;
["F"] BEGIN OUTSTR("FONT (BDR,BDI)←");FNT←INCHWL;END;
["G"] GEOMED;
["H"] BEGIN HIDE←1-HIDE;END;
["L"] IF LABOK THEN LABOK←0 ELSE LABOK←-1;
["N"] BEGIN OUTSTR("am-dis ("&CVF(LDIS)&")←");
IF LENGTH(S←INCHWL) THEN LDIS←REALSCAN(S,0);END;
["O"] if meta then BEGIN OUTSTR("CHANGE(S) X2,Y2:");
X2←X2+CVD(INSTR(","));Y2←Y2+CVD(INCHWL);END else
if ctrl then BEGIN OUTSTR("CHANGE(S) X1,Y1:");
X1←X1+CVD(INSTR(","));Y1←Y1+CVD(INCHWL);END;
["T"] TXT←1-TXT;
["Q"] IF R90 THEN R90←0 ELSE R90←-1;
["R"] if meta then BEGIN ANGLE←ANGLE/2;SNSPL←-SIN(ANGLE);
CSPL←COS(ANGLE);END else
if ctrl then ROTDEL ← ROTDEL/2 else
BEGIN WROOM←1-WROOM;
IF NOT HAVROOM THEN GETROOM ELSE REROOM;
END;
["S"] if meta or ctrl then begin
if meta then BEGIN IF SHOW[2] THEN SHOW[2]←0
ELSE SHOW[2]←-1; IF NOFIL2 THEN SHOW[2]←0;END;
if ctrl then BEGIN IF SHOW[1] THEN SHOW[1]←0
ELSE SHOW[1]←-1; END;
end else
BEGIN OUTSTR("qrsiz ("&CVF(SIZ)&")←");
IF LENGTH(S←INCHWL) THEN BEGIN
R←REALSCAN(S,0);R1←R/SIZ;SIZ←R;
FOR I←1 TIL NPNTS DO BEGIN
SHRINK(-CUBE[I],R1,R1,R1);
SHRINK(-WALL[I],0,R1,R1);
SHRINK(-FLOOR[I],R1,0,R1);
END;
END;
END;
["X"] if meta then FOR I←NPNTS+1 TIL 2*NPNTS DO
VERTWC[1,I]←-VERTWC[1,I] else
if ctrl then FOR I←1 TIL NPNTS DO
VERTWC[1,I]←-VERTWC[1,I] else
BEGIN OUTCHR(":");KKK←INCHRW;
IF KKK="L" THEN BEGIN
OUTSTR("etter offset <CUBES> ("&CVS(LETX)&")←");
IF LENGTH(S←INCHWL) THEN LETX←CVD(S);
OUTSTR("Letter minscale ("&CVF(RDSCAL)&")←");
IF LENGTH(S←INCHWL) THEN RDSCAL←REALSCAN(S,0);
OUTSTR("Letter offset <SHADOW> ("&CVS(LETXX)&")←");
IF LENGTH(S←INCHWL) THEN LETXX←CVD(S);END;
IF KKK="S" THEN BEGIN
OUTSTR("cale (1/"&CVF(XSCL)&")←1/");
IF LENGTH(S←INCHWL) THEN XSCL←REALSCAN(S,0);
END;
END;
["Y"] if meta then FOR I←NPNTS+1 TIL 2*NPNTS DO
VERTWC[2,I]←-VERTWC[2,I] else
if ctrl then FOR I←1 TIL NPNTS DO
VERTWC[2,I]←-VERTWC[2,I] else
BEGIN OUTCHR(":");KKK←INCHRW;
IF KKK="L" THEN BEGIN
OUTSTR("etter offset <CUBES> ("&CVS(LETY)&")←");
IF LENGTH(S←INCHWL) THEN LETY←CVD(S);
OUTSTR("Letter offset <SHADOW> ("&CVS(LETYY)&")←");
IF LENGTH(S←INCHWL) THEN LETYY←CVD(S);END;
IF KKK="S" THEN BEGIN
OUTSTR("cale (1/"&CVF(YSCL)&")←1/");
IF LENGTH(S←INCHWL) THEN YSCL←REALSCAN(S,0);
END;
END;
["Z"] if meta then FOR I←NPNTS+1 TIL 2*NPNTS DO
VERTWC[3,I]←-VERTWC[3,I] else
if ctrl then FOR I←1 TIL NPNTS DO
VERTWC[3,I]←-VERTWC[3,I];
["≡"] BEGIN PTOCHW(0,"≡"+'200);PTOCHW(0,"E"+'600);
GEOMED;END;
["≥"] ALTSIZ(0);
["≤"] ALTSIZ(1);
["2"] SETSTF;
["+"] IF AXOK THEN AXOK←0 ELSE AXOK←-1;
["}"] TRCAM(.3,.1,"X");
["{"] TRCAM(-.3,-.1,"X");
["'"] TRCAM(.3,.1,"Y");
["`"] TRCAM(-.3,-.1,"Y");
[">"] SHWALL(1.35,1.15);
["<"] SHWALL(1/1.35,1/1.15);
["↑"] IF META OR CTRL THEN BEGIN
if meta then R←π/8 else if ctrl then R←π/16;
CAMX←CAMX+R; ROTATE(XWD(FR,CAM),R,0,0);
END ELSE ASKCAM("X",CAMX);
["↓"] IF META OR CTRL THEN BEGIN
if meta then R←-π/8 else if ctrl then R←-π/16;
CAMX←CAMX+R; ROTATE(XWD(FR,CAM),R,0,0);
END ELSE ASKCAM("X",CAMX);
["←"] IF META OR CTRL THEN BEGIN
if meta then R←π/8 else if ctrl then R←π/16;
CAMY←CAMY+R; ROTATE(XWD(FR,CAM),0,R,0);
END ELSE ASKCAM("Y",CAMY);
["→"] IF META OR CTRL THEN BEGIN
if meta then R←-π/8 else if ctrl then R←-π/16;
CAMY←CAMY+R; ROTATE(XWD(FR,CAM),0,R,0);
END ELSE ASKCAM("Y",CAMY);
["↔"] BEGIN if meta then R←-.25 else
if ctrl then R←.25 else
BEGIN OUTSTR(" change distance ←");R←0;
IF LENGTH(S←INCHWL) THEN R←REALSCAN(S,0);END;
TRANSL(-CAM,0,0,R);
END;
["\"] IF ¬WROOM THEN BEGIN
if meta then SCALE[2]←SCALE[2]/0.92 else
if ctrl then BEGIN ASCALE←0; SCALE[1]←SCALE[1]/0.92;END
else ASCALE←1;
END ELSE BEGIN if ctrl then R1←1/0.86 else R1←1/0.92;
SHROOM(R1);END;
["/"] IF ¬WROOM THEN BEGIN
if meta then SCALE[2]←SCALE[2]*0.92 else
if ctrl then BEGIN SCALE[1]←SCALE[1]*0.92;ASCALE←0;END
else ASCALE←1;
END ELSE BEGIN if ctrl then R1←1*0.86 else R1←1*0.92;
SHROOM(R1);END;
["="] BEGIN if ctrl then R←.88 else R←.95;
STROOM(R); END;
["≠"] BEGIN if ctrl then R←1/.88 else R←1/.95;
STROOM(R); END;
["["] BEGIN if meta then R←.75 else if ctrl then R←.88
else R←.95;STRSQR(R); END;
["]"] BEGIN if meta then R←1/.75 else if ctrl then R←1/.88
else R←1/.95;STRSQR(R); END;
["?"] OUTSTR("
{Red,Exp}+{αrot,βdubl} /\{βall}scl Show 2dubl -*();:_rot Plot Bigltr
XYZ-reflt Qrtr Lab +axes DstQ Orgn ≥≤altsiz Txt ][altzsqr
{}`'camX,Y =≠{βall_⊗xset}altzdst Sqrsiz <>rsiz ↔camdst X,Y:Ltr,Scl ")
END "CHRLST";
END;
PROCEDURE MOVSHO;
BEGIN
START_CODE "MOVSHO"
DEFINE XL="4",YL="5",ZL="3",XR="6",YR="7",ZR="'10";
DEFINE I="'14",PNT="'11",CH="'13",REP="'15";
DEFINE SP="'16",P="'17",FIX="'126000000000";
DEFINE INCHRX="'051100000000",INCHRY="'051000000000";
LABEL MOV,SHO,CT2,CT3,CT4,CT5,CT6,CK2,CK4,CK6,KTES,LOP2,
KGET,STPQ,WCHR,KSET,XXX,XIT,DIS,NODIS,SETRIG,XRP,
PRO,DDV,AGN,SET90,OTO,OT2,CT1,CT7,XOT,XIT2,STPUP,
NOBRI,NOBR2,SKPRIT,SKPR1,SKPR2,SKPR3,XXNR,XXYR,
ACPUSH,ACPOP,ACSAV,ACS14,ACS15,
NROOM,NODIF1,RM1,RM2,RM3,RMSHO,RMX,RMY,RMZ,NUR;
PUSH P,DPYBUF;
PUSHJ P,DPYSET;
MOVEI PNT,0;
MOVEI REP,0;
SETOM SKMOV;
JRST MOV;
KGET: INCHRX CH;
JRST STPQ;
JRST KSET;
STPQ: SKIPE STP;
JRST AGN;
WCHR: INCHRY CH;
KSET: MOVE 1,CTRL;
MOVEM 1,OLDCTR;
MOVE 1,META;
MOVEM 1,OLDMET;
MOVE 1,KHR;
MOVEM 1,OLDKHR;
MOVE 1,CH;
ANDI 1,'200;
MOVEM 1,CTRL;
MOVE 1,CH;
ANDI 1,'400;
MOVEM 1,META;
ANDI CH,'177;
MOVEM CH,KHR;
JRST AGN;
AGN: MOVE CH,KHR;
CAIE CH,"P";
JRST LOP2;
PUSHJ P,DPYIT;
PUSHJ P,CALPLO;
SKIPN WROOM;
JRST WCHR;
SETOM PLT;
PUSHJ P,LETRS;
SETZM PLT;
PUSHJ P,NEWRLD;
PUSHJ P,DPYIT;
PUSHJ P,CALPLO;
PUSHJ P,OLWRLD;
JRST WCHR;
LOP2: SKIPE WROOM;
JRST KTES;
PUSH P,DPYBUF;
PUSHJ P,DPYSET;
KTES: MOVEI PNT,0;
MOVEI REP,0;
CAIN CH,";";
JRST SETRIG;
CAIN CH,":";
JRST SETRIG;
CAIN CH,")";
JRST SETRIG;
CAIN CH,"(";
JRST SETRIG;
CAIN CH,"-";
JRST SETRIG;
CAIN CH,"*";
JRST SETRIG;
XOT: CAIE CH,'40;
JRST OT2;
SETZM STP;
JRST WCHR;
OT2: CAIE CH,'175;
JRST OTO;
JRST XXX;
OTO: PUSH P,CH;
PUSHJ P,KHRSET;
SKIPE STP;
JRST STPUP;
SETOM SKMOV;
SETZB REP,PNT;
JRST MOV;
STPUP: MOVE 1,OLDKHR;
MOVEM 1,KHR;
MOVE 1,OLDMET;
MOVEM 1,META;
MOVE 1,OLDCTR;
MOVEM 1,CTRL;
JRST AGN;
SETRIG: SKIPE R90;
JRST SET90;
PUSHJ P,ACPUSH;
PUSH P,ROTDEL;
PUSHJ P,SIN;
MOVEM 1,SN;
PUSH P,ROTDEL;
PUSHJ P,COS;
MOVEM 1,CS;
PUSHJ P,ACPOP;
JRST CT1;
SET90: MOVE 1,ONE;
MOVEM 1,SN;
SETZM CS;
CT1: CAIE CH,";";
JRST CT2;
MOVN 1,SN;
MOVEM 1,SN;
JRST CK2;
CT2: CAIE CH,":";
JRST CT3;
CK2: MOVE 1,ADY;
MOVEM 1,AD1;
MOVE 2,ADZ;
MOVEM 2,AD2;
SKIPE CTRL;
SETOM STP;
SKIPN AXOK;
JRST MOV;
SKIPE PNT;
JRST MOV;
MOVEI I,1;
MOVEM I,AXNUM;
JRST MOV;
CT3: CAIE CH,"(";
JRST CT4;
MOVN 1,SN;
MOVEM 1,SN;
JRST CK4;
CT4: CAIE CH,")";
JRST CT5;
CK4: MOVE 1,ADZ;
MOVEM 1,AD1;
MOVE 2,ADX;
MOVEM 2,AD2;
SKIPE CTRL;
SETOM STP;
SKIPN AXOK;
JRST MOV;
SKIPE PNT;
JRST MOV;
MOVEI I,2;
MOVEM I,AXNUM;
JRST MOV;
CT5: CAIE CH,"-";
JRST CT6;
MOVN 1,SN;
MOVEM 1,SN;
JRST CK6;
CT6: CAIE CH,"*";
JRST KTES;
CK6: MOVE 1,ADX;
MOVEM 1,AD1;
MOVE 2,ADY;
MOVEM 2,AD2;
SKIPE CTRL;
SETOM STP;
SKIPN AXOK;
JRST MOV;
SKIPE PNT;
JRST MOV;
MOVEI I,3;
MOVEM I,AXNUM;
JRST MOV;
MOV: SKIPN @SHOPP;
JRST XRP;
MOVE I,PNT;
SKIPE REP;
ADD I,NPNTS;
SKIPE SKMOV;
JRST PRO;
SKIPE META;
JUMPE REP,PRO;
SKIPN META;
JUMPN REP,PRO;
MOVE 1,@AD1;
MOVE 2,@AD2;
MOVE 3,1;
MOVE 4,2;
FMPR 1,CS;
FMPR 2,SN;
FSBR 1,2;
MOVEM 1,@AD1;
SKIPN WROOM;
JRST NODIF1;
MOVE 1;
FSBR 3;
MOVEM DIF1;
MOVE 4;
NODIF1: FMPR 3,SN;
FMPR 4,CS;
FADR 3,4;
MOVEM 3,@AD2;
SKIPN WROOM;
JRST PRO;
FSBR 3;
MOVNM DIF2;
PRO: SKIPE NOREP;
JRST SKPR1;
MOVE ZR,@ADZ;
MOVE 1,@ADX;
MOVE XR,ZR;
MOVE 2,1;
FMPR ZR,CSPL;
FMPR 1,SNSPL;
FSBR ZR,1;
FMPR XR,SNSPL;
FMPR 2,CSPL;
FADR XR,2;
FMPR XR,@SCALP;
SKPR1: SKIPE WROOM;
JRST RM1;
MOVE XL,@ADX;
FMPR XL,@SCALP;
MOVE YL,@ADY;
FMPR YL,@SCALP;
MOVE YR,YL;
SKIPN DISTQ;
JRST NODIS;
DIS: MOVE ZL,@ADZ;
FSBR ZL,CZ;
SKIPN NOREP;
FSBR ZR,CZ;
SETOM BRIDF;
JRST DDV;
NODIS: MOVN ZL,CZ;
MOVN ZR,CZ;
SETZM BRIDF;
DDV: FDVR XL,ZL;
FDVR YL,ZL;
SKIPE NOREP;
JRST SHO;
FDVR XR,ZR;
FDVR YR,ZR;
SHO: SKIPN BRIDF;
JRST NOBRI;
FADR ZL,CZ;
FADR ZL,TWO;
SKIPE NOREP;
JRST SKPR2;
FADR ZR,CZ;
FADR ZR,TWO;
SKPR2: MOVE 1,NUMBR;
FMPR 1,ZL;
FADR 1,NUMBR;
FMPR ZL,TWO;
SKIPE NOREP;
JRST SKPR3;
MOVE 2,NUMBR;
FMPR 2,ZR;
FADR 2,NUMBR;
FMPR ZR,TWO;
FIX ZR,ZR;
FIX 2,2;
MOVEM 2,OFFR;
SKPR3: FIX ZL,ZL;
FIX 1,1;
MOVEM 1,OFFL;
PUSH P,ZL;
PUSHJ P,DPYBRT;
NOBRI: FIX XL,XL;
ADD XL,X1;
PUSH P,XL;
FIX YL,YL;
ADD YL,Y1;
PUSH P,YL;
PUSHJ P,ACPUSH;
PUSHJ P,APOINT;
PUSHJ P,ACPOP;
MOVE I,PNT;
SKIPE REP;
ADD I,NPNTS;
LSH I,1;
PUSH SP,@LABP;
PUSH SP,@LABS;
PUSHJ P,ACPUSH;
PUSHJ P,DPYSST;
PUSHJ P,ACPOP;
SKIPE NOREP;
JRST SKPRIT;
SKIPN BRIDF;
JRST NOBR2;
PUSH P,ZR;
PUSHJ P,DPYBRT;
NOBR2: FIX XR,XR;
ADD XR,X2;
PUSH P,XR;
FIX YR,YR;
ADD YR,Y2;
PUSH P,YR;
PUSHJ P,APOINT;
PUSH SP,@LABP;
PUSH SP,@LABS;
PUSHJ P,DPYSST;
JRST SKPRIT;
RM1: MOVEI 1,0;
MOVEI 2,0;
MOVEI 3,0;
CAIN CH,";";
JRST RMX;
CAIE CH,":";
JRST RM2;
RMX: MOVEI 1,0;
MOVE 2,DIF1;
MOVE 3,DIF2;
JRST RMSHO;
RM2: CAIN CH,")";
JRST RMY;
CAIE CH,"(";
JRST RM3;
RMY: MOVEI 2,0;
MOVE 3,DIF1;
MOVE 1,DIF2;
JRST RMSHO;
RM3: CAIN CH,"-";
JRST RMZ;
CAIE CH,"*";
JRST NUR;
RMZ: MOVEI 3,0;
MOVE 1,DIF1;
MOVE 2,DIF2;
JRST RMSHO;
NUR: SKIPN NUROOM;
JRST SKPRIT;
SOS NUROOM;
MOVE 1,@ADX;
MOVE 2,@ADY;
MOVE 3,@ADZ;
RMSHO: PUSH P,@CUBP;
PUSH P,1;
PUSH P,2;
PUSH P,3;
PUSHJ P,ACPUSH;
PUSHJ P,TRANSL;
PUSHJ P,ACPOP;
PUSH P,@WALP;
PUSH P,[0];
PUSH P,2;
PUSH P,3;
PUSHJ P,ACPUSH;
PUSHJ P,TRANSL;
PUSHJ P,ACPOP;
PUSH P,@FLOP;
PUSH P,1;
PUSH P,[0];
PUSH P,3;
PUSHJ P,ACPUSH;
PUSHJ P,TRANSL;
PUSHJ P,ACPOP;
SKPRIT: ADDI PNT,1;
CAME PNT,NPNTS;
JRST MOV;
XRP: SKIPE REP;
JRST XIT;
ADDI REP,1;
SETZM PNT;
JRST MOV;
XIT: SKIPN AXOK;
JRST XIT2;
PUSHJ P,SHAX;
XIT2: SKIPN WROOM;
JRST XXNR;
PUSHJ P,ACPUSH;
PUSHJ P,DPYIT;
SKIPN TXT;
PUSHJ P,LETRS;
SKIPE TXT;
PUSHJ P,TXTROOM;
PUSHJ P,ACPOP;
JRST XXYR;
XXNR: SKIPE LABOK;
PUSHJ P,SHLAB;
MOVEI I,1;
PUSH P,I;
PUSHJ P,ACPUSH;
PUSHJ P,DPYOUT;
PUSHJ P,ACPOP;
XXYR: SETZM SKMOV;
SKIPN CONVSHO;
JRST KGET;
PUSH P,DPYBUF;
PUSHJ P,ACPUSH;
PUSHJ P,DPYSET;
PUSHJ P,ACPOP;
JRST XXX;
ACPUSH: MOVEM '15,ACS15;
MOVEI '15,ACSAV;
BLT '15,ACS14;
POPJ P,;
ACPOP: MOVSI '15,ACSAV;
BLT '15,'15;
POPJ P,;
ACSAV: 0;
0;
0;
0;
0;
0;
0;
0;
0;
0;
0;
0;
ACS14: 0;
ACS15: 0;
0;
0;
XXX: AOJ 1;
END "MOVSHO";
END;
IFC CONVERG THENC
PROCEDURE FCALL;
COMMENT FMFP(FUNCT,9,A,VAL,GRAD,CUTOFF,10@-8,LIM,IER,H);
START_CODE "FCALL"
INTEGER SAVE12,SAVE16,SAVE17;
LABEL ALOC,GLOC,HLOC;
MOVEM '12,SAVE12;MOVEM '16,SAVE16;MOVEM '17,SAVE17;
MOVE 1,A;HRRM 1,ALOC;
MOVE 1,GRAD;HRRM 1,GLOC;
MOVE 1,H;HRRM 1,HLOC;
JSA '16,FMFP;
JUMP FUNCT;
JUMP [9];
ALOC: JUMP 0;
JUMP VAL;
GLOC: JUMP 0;
JUMP CUTOFF;
JUMP [1.0@-6];
JUMP LIM;
JUMP IER;
HLOC: JUMP 0;
MOVE '12,SAVE12;MOVE '16,SAVE16;MOVE '17,SAVE17;
END "FCALL";
INTERNAL PROCEDURE SFUNCT(INTEGER N;REAL ARRAY A;
REFERENCE REAL VAL;REFERENCE REAL ARRAY GRAD);
BEGIN INTEGER I;REAL R1,R2,R3;
IF VAL THEN OUTSTR(CVF(VAL)&↓);
COMMENT
KHR←"⊗" STP←0 MOVSHO;
VAL←0; ARRCLR(GRAD);
FOR I←1 TIL NPNTS DO BEGIN
R1←SAVEWC[1,I+NPNTS]-A[1,1]*SAVEWC[1,I]-
A[1,2]*SAVEWC[2,I]-A[1,3]*SAVEWC[3,I];
R2←SAVEWC[2,I+NPNTS]-A[2,1]*SAVEWC[1,I]-
A[2,2]*SAVEWC[2,I]-A[2,3]*SAVEWC[3,I];
R3←SAVEWC[3,I+NPNTS]-A[3,1]*SAVEWC[1,I]-
A[3,2]*SAVEWC[2,I]-A[3,3]*SAVEWC[3,I];
VAL←VAL+R1*R1+R2*R2+R3*R3;
GRAD[1,1]←GRAD[1,1]+R1*SAVEWC[1,I];
GRAD[1,2]←GRAD[1,2]+R1*SAVEWC[2,I];
GRAD[1,3]←GRAD[1,3]+R1*SAVEWC[3,I];
GRAD[2,1]←GRAD[2,1]+R2*SAVEWC[1,I];
GRAD[2,2]←GRAD[2,2]+R2*SAVEWC[2,I];
GRAD[2,3]←GRAD[2,3]+R2*SAVEWC[3,I];
GRAD[3,1]←GRAD[3,1]+R3*SAVEWC[1,I];
GRAD[3,2]←GRAD[3,2]+R3*SAVEWC[2,I];
GRAD[3,3]←GRAD[3,3]+R3*SAVEWC[3,I];
VERTWC[1,I]←-R1+SAVEWC[1,I+NPNTS];
VERTWC[2,I]←-R2+SAVEWC[2,I+NPNTS];
VERTWC[3,I]←-R3+SAVEWC[3,I+NPNTS];
END;
GRAD[1,1]←GRAD[1,1]*-2;GRAD[1,2]←GRAD[1,2]*-2;
GRAD[1,3]←GRAD[1,3]*-2;GRAD[2,1]←GRAD[2,1]*-2;
GRAD[2,2]←GRAD[2,2]*-2;GRAD[2,3]←GRAD[2,3]*-2;
GRAD[3,1]←GRAD[3,1]*-2;GRAD[3,2]←GRAD[3,2]*-2;
GRAD[3,3]←GRAD[3,3]*-2;
END;
ENDC
PROCEDURE FILOPEN(INTEGER NEWONE);
CASE NEWONE OF BEGIN
[1] BEGIN LABEL AG1;
AG1: OUTSTR("Data File 1 : ");DATFIL[1]←INCHWL&".DAT";
S←DATFIL[1];DEV←SCAN(S,13,I);
IF I≠":" THEN BEGIN S←DEV;DEV←"DSK";END
ELSE IF DEV="U" THEN DEV←"UDP" ELSE DEV←"DSK";
OPEN(5,DEV,0,3,3,128,BRK,EOF);LOOKUP(5,S,FAIL);
IF FAIL THEN BEGIN OUTSTR("NOT HERE "&DATFIL[1]&↓);
GO TO AG1;END;
DO S←INPUT(5,3) UNTIL BRK="#";
S←INPUT(5,4);
S←INPUT(5,6);BIGDIM←CVD(S);
S←INPUT(5,4);
S←INPUT(5,6);NPNTS←CVD(S);NPSAV←NPNTS;
CLOSE(5);RELEASE(5);
END;
[2] BEGIN LABEL AG2;
AG2: OUTSTR("Data File 2 : ");
IF LENGTH(S←INCHWL)>0 AND NOT EQU(S,"SHEPARD")
THEN BEGIN
DATFIL[2]←S&".DAT"; S←DATFIL[2];DEV←SCAN(S,13,I);
IF I≠":" THEN BEGIN S←DEV;DEV←"DSK";END
ELSE IF DEV="U" THEN DEV←"UDP" ELSE DEV←"DSK";
OPEN(5,DEV,0,3,3,128,BRK,EOF);LOOKUP(5,S,FAIL);
IF FAIL THEN BEGIN OUTSTR("NOT HERE "&DATFIL[2]&↓);
GO TO AG2;END;
CLOSE(5);RELEASE(5);NOFIL2←0;
END ELSE BEGIN NOFIL2←-1; SHOW[2]←0; NEW2←0; END;
IF EQU(S,"SHEPARD") THEN SHEPARD←TRUE ELSE SHEPARD←FALSE;
END
END;
PROCEDURE DATNEW(INTEGER NEWONE);
BEGIN ROTDEL ← π/128; TRNDEL ← 0.1; WROOM←ROOMDIV←MROOM←0;
ANGLE←π/32;Y1←Y2←0;SIZ←.11;RSIZ←1.7;WSQZ←.65;
LETX←8;LETY←10;SZSCAL←1;LDIS←0;BSIZ←4;
LETXX←6;LETYY←5;SMLETS←0;RMIN←3;RDSCAL←24;
SNSPL←-SIN(ANGLE); CSPL← COS(ANGLE);
CZ ← 5.0; SCALE[NEWONE] ← -1350;
DISTQ←-1; LABOK←0; AXOK←0; R90←0; HIDE←0;
AXIS[1]←"X";AXIS[2]←"Y"; KSCALE←ASCALE←475.0;
SHOW[NEWONE]←-1;
END;
PROCEDURE LABNEW(INTEGER LNUM);
BEGIN LABEL AGL;
AGL: OUTSTR("abel File: ");LABFIL←INCHWL;
S←LABFIL;DEV←SCAN(S,13,I);
IF I≠":" THEN BEGIN S←DEV;DEV←"DSK";END
ELSE IF DEV="U" THEN DEV←"UDP" ELSE DEV←"DSK";
OPEN(9,DEV,0,3,3,128,BRK9,EOF);LOOKUP(9,S,FAIL);
IF FAIL THEN BEGIN OUTSTR("NOT FOUND "&LABFIL);
OUTCHR("L");GO TO AGL;END;
DO S←INPUT(9,9) UNTIL BRK9=";";
FOR I←(LNUM-1)*NPNTS+1 TIL LNUM*NPNTS DO BEGIN
S←INPUT(9,9);IF I≠LNUM*NPNTS ∧ BRK9=";" THEN USERERR(0,0,"
BAD LABEL INPUT NUMBER "&CVS(I));
LABL[I]←LABL[I+NPNTS]←NULL;
DO BEGIN
J←LOP(S);IF J="." THEN DONE;
IF LNUM=2 AND (J<"0" OR J>"9")
THEN J←J+'40;
LABL[I]←LABL[I]&J;
IF LNUM≠2 THEN BEGIN
IF J<"0" OR J>"9" THEN J←J+'40;
LABL[I+NPNTS]←LABL[I+NPNTS]&J;
END;
END UNTIL FALSE;
END;
FOR I←1 TIL LPNTS DO LABSAV[I]←LABL[I];
CLOSE(9);RELEASE(9);
END;
PROCEDURE ALLCHR;
BEGIN REAL ARRAY V[1:BIGDIM,1:LPNTS];
INTEGER I,J,K,L,M; REAL ANG,SNL1,SNL2,CSL1,CSL2;
NEW1←1;ALLDIM←1; DATIN(V);
ANG←5/360*π;SNL1←SIN(ANG);CSL1←COS(ANG);
SNL2←SIN(-ANG);CSL2←COS(-ANG);
I←1;J←2;
WHILE TRUE DO BEGIN LABEL AG;
SUBNOW←0;ALLSHO(NPNTS,V);
IF SUBIN AND NDIMS≤4 THEN BEGIN
SUBNOW←1;SUBIN←0;DATIN(V);SUBIN←1;
ALLSHO(NPNTS,V);
END;
AG: CHR←INCHRW;OUTCHR(" ");
IF CHR≥"(" AND CHR≤'175 THEN
CASE CHR OF BEGIN
["+"] BEGIN ANG←ANG*1.3;SNL1←SIN(ANG);CSL1←COS(ANG);
SNL2←SIN(-ANG);CSL2←COS(-ANG);GO TO AG;END;
["-"] BEGIN ANG←ANG/1.3;SSNL←SIN(ANG);CCSL←COS(ANG);
SNL2←SIN(-ANG);CSL2←COS(-ANG);GO TO AG;END;
["("] BEGIN SNL←SNL1;CSL←CSL1;ROT2(I,J,NPNTS,V);END;
[")"] BEGIN SNL←SNL2;CSL←CSL2;ROT2(I,J,NPNTS,V);END;
['175] BEGIN ALLDIM←NEW1←0;RETURN;END;
["?"] BEGIN
OUTSTR(" +-=Ang ()=Rot <alt>=xit IJ=dims File Trns."&↓);
GO TO AG;END;
["T"] BEGIN K←CVD(CHR←INCHRW);L←CVD(CHR←INCHRW);
FOR M←1 TIL NPNTS DO V[K,M]↔V[L,M];END;
["I"] BEGIN I←CVD(CHR←INCHRW);GO TO AG;END;
["J"] BEGIN J←CVD(CHR←INCHRW);GO TO AG;END;
["F"] BEGIN LSTDIM(I,J,NPNTS,V);GO TO AG;END
END ELSE BEGIN OUTCHR("?");GO TO AG;END;
END;
END;
PROCEDURE GETCHR;
BEGIN INTEGER CHR,META,CTRL;STRING S;
OUTCHR(">");
CHR←INCHRW; META←CTRL←0;
IF CHR>'400 THEN BEGIN META←1;CHR←CHR-'400;END;
IF CHR>'200 THEN BEGIN CTRL←1;CHR←CHR-'200;END;
IF CHR≥'15 AND CHR≤"T" THEN
CASE CHR OF BEGIN
["I"] IF SUBIN THEN BEGIN SUBIN←0;NPNTS←NPSAV;
FOR I←1 TIL LPNTS DO LABL[I]←LABSAV[I];END
ELSE BEGIN SUBIN←1;NEW1←1;IF ¬NOFIL2 THEN NEW2←1;END;
["N"] BEGIN OUTSTR("pnts: "); NPNTS←CVD(INCHWL);
FOR I←1 TIL NPNTS DO BEGIN
LABL[I+NPNTS]←LABL[I+NPSAV];
FOR J←1 TIL 3 DO VERTWC[J,I+NPNTS]←VERTWC[J,I+NPSAV];
END;
END;
["T"] SETSTF;
["F"] LSTDIM(1,2,NPNTS,VERTWC);
["."] SHRT←1-SHRT;
["?"] OUTSTR(
" Inds Tsplit αβGet Convrg_Error_Maxitrs Shep Dims Labs File Alldim Npnts.");
['15] BEGIN CHR←INCHRW;GOSHO←1; END;
["C"] CONVSHO←1;
["A"] ALLCHR;
["L"] BEGIN
IF CTRL OR ¬META THEN LABNEW(1);
IF META THEN LABNEW(2);
END;
["E"] BEGIN OUTSTR("rror "); S←INCHWL;
CUTOFF←REALSCAN(S,0);END;
["M"] BEGIN OUTSTR("ax Number of Iterations ");
LIM←CVD(INCHWL);END;
["S"] BEGIN SHEPARD←NEW1←1;DATIN(FOO);SHEP_DRAW(0);NEW1←0;END;
["P"] BEGIN SHEPARD←NEW1←1;DATIN(FOO);SHEP_DRAW(1);NEW1←0;END;
["D"] BEGIN NEW1←1;IF ¬NOFIL2 THEN NEW2←1;END;
["G"] BEGIN
IF CTRL OR ¬META THEN BEGIN DATNEW(1);NEW1←1;FILOPEN(1);END;
IF META THEN BEGIN DATNEW(2);NEW1←1;FILOPEN(2);END;
IF SPLIT THEN SETSTF;
END
END ELSE OUTCHR("?");
OUTSTR(↓);
END;
α INITIALIZATION;
QUICK_CODE PPIOT 3,'3001;PPIOT 2,-470;END;
CUTOFF←.01;LIM←10;SUBIN←0;SCAL←200;HAVROOM←0;
ONE←1.0;TWO←2.0;THREE←3.0;NUMBR←10.0;SCL←3.5;
TXT←1;TST←0;PLT←0;XSCL←5.6;YSCL←4.2;
START_CODE "SETUP"
MOVE 1,WALL;HRLI 1,'11;MOVEM 1,WALP;
MOVE 1,FLOOR;HRLI 1,'11;MOVEM 1,FLOP;
MOVE 1,CUBE;HRLI 1,'11;MOVEM 1,CUBP;
MOVE 1,SCALE;HRLI 1,'15;MOVEM 1,SCALP;
MOVE 1,SHOW;HRLI 1,'15;MOVEM 1,SHOPP;
MOVE 1,VERTWC;HRLI 1,'14;MOVEM 1,ADX;
ADDI 1,LPNTS;MOVEM 1,ADY;
ADDI 1,LPNTS;MOVEM 1,ADZ;
MOVE 1,LABL;HRLI 1,'14;MOVEM 1,LABS;
SUBI 1,1;MOVEM 1,LABP;
END "SETUP";
NUMSET←"0123456789.-";
SETBREAK(3,"#"&'12," "&NUMSET&'15,"INS");
SETBREAK(11,">"&'12," "&NUMSET&'15,"INS");
SETBREAK(12,"%"&'12," "&NUMSET&'15,"INS");
SETBREAK(4,NUMSET,"","INR");
SETBREAK(6,NUMSET,"","XNS");
SETBREAK(13,":","","INS");
SETBREAK(7,'12,'15,"INS");
SETBREAK(9,",;",↓,"INS");
SETBREAK(10,".",↓,"INS");
NEW1←NEW2←PASS1←1;
DATNEW(1);DATNEW(2);SETSTF;
FILOPEN(1);FILOPEN(2);
OUTCHR("L");LABNEW(1);
NEW1←NEW2←0;
WHILE TRUE DO BEGIN "MLOP"
GETCHR;
IF ¬NDIMS THEN NEW1←1;
IF NEW1 OR NEW2 THEN DATIN(FOO);
NEW1←NEW2←0;
IFC CONVERG THENC
IF CONVSHO THEN BEGIN
ARRBLT(SAVEWC[1,1],VERTWC[1,1],LPNTS*3);
FCALL;END;
ENDC
STP←0;KHR←"⊗";CONVSHO←0;
IF GOSHO THEN MOVSHO;GOSHO←0;
END "MLOP";
END "MDC";